COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	PROVISOIRE
C00007 ENDMK
C⊗;
;PROVISOIRE;
(DE SEQN () (SEQ))

(SETQ $STEP T)


(DF DEF-MOD (L)
  (PUT (CAR L)
       (APPEND '((ARG /.) (IT NIL) (NARC 0))
		(LET ((X (CADR L))) (COND
			((NULL X) [['NAME: (CAR L)]])
			((EQ (CAR X) 'TARGS:) (SELF (CDDR X)))
			((EQ (CAR X) 'LOC:)
			 (NCONC (MAPCAR (CADR X) (LAMBDA (X) [X NIL]))
				(SELF (CDDR X))))
			(T (CONS [(CAR X) (CADR X)]
				 (SELF (CDDR X))))
				     )))
       '$M)
  (PUT (CAR L) (GET (CADR L) 'TARGS:) 'TARGS:)
  )

(STATUS 18 '/, (LAMBDA () ['CADR ['ASSQ [QUOTE (READ)] '$FC]]))
(STATUS 18 '/# (LAMBDA () ['EV (READ)]))

(DM SETQM (L) (RPLACB L
  ['SET ['CASSQ [QUOTE (CADR L)] '$FC] (CADDR L)]))

(DF SIGNAL (-L-) (SELECTQ (CAR -L-)
  (USER (PRINT 'SIGNAL (CADR -L-)))
  ()))


;	******* INTERP MOD-LANG ******** ;


(DE ESSAI (ENTREE)
  (SETQ $E ENTREE)
  (PUSH (SETQ $FC NIL))  ; NULL INITIAL FRAME ;
  (PUSH (LAMBDA () (SETQ $OK NIL)))
  (VERIF-LOOP))

(DE VERIF-LOOP ()
  (SETQ $OK T
        $PC 'M-INIT
        $M (CAR $E))
  (WHILE $OK (IF $STEP (STEPPER)) ($PC))
  'THE-END)
  
(DE M-INIT ()
  (PUSH $FC)
  (SETQ $FC (SUBST (CDR $E) '/. (GET $M '$M))
	$PC 'M-EVAL
	$C  (GET $M 'TARGS:)))

(DE M-EVAL ()
  (SETQ $PC (NEXTL $C))
  (PUSH (LAMBDA ()
	  (IF (CHECK ,IT ,RES:) 'OK
              (SIGNAL USER 5))
	  (SETQ $FC (POP))
	  (SETQ $PC (POP))))
  )


(DE ORDER-EVAL () (SETQ $PC (NEXTL $C)))

(DE LSEQ ()
  (EPROGN $C) (SETQ $PC (POP)))

(DE EV ()
  (EVAL (CAR $C)) (SETQ $PC (POP)))

(DE SEQ ()
  (IF (NULL $C)
      (PROGN
	(AND ,ARG (SIGNAL USER 1))
	(SETQ $PC (POP)))
      (PUSH (CDR $C) 'SEQ2)
      (SETQ $C (CAR $C) $PC 'ORDER-EVAL)))

(DE SEQ2 ()
  (SETQ $C (POP) $PC 'SEQ))

(DE VERIFY (;; ARG)
  (SETQ ARG (CAR ,ARG))
  (SETQM ARG (CDR ,ARG))
  (COND
    ((IS-CONST ARG) (SETQ ARG (CLASSIFY ARG))
		    (CHECK ARG (CAR $C))
		    (SETQM IT ARG)
		    (SETQ $PC (POP)))
  ))

(DE IS-CONST (L)
  (OR (ATOM L) (EQ (CAR L) QUOTE)))

(DE CLASSIFY (L) (COND
  ((NUMBP L) ['KST-NUM L])
  ((MEMQ L '(T NIL)) ['KST-AT L])
  ((ATOM L) ['VAR L])
  ((EQ (CAR L) QUOTE) (IF (ATOM (CADR L)) ['KST-AT (CADR L)]
			  ['KST-LIST (CADR L)]))
  ))

(DE CHECK (X TY) (COND
  ((EQ (CAR X) 'VAR) 'OK)
  ((ATOM TY) (SELECTQ TY
		(ANY 'OK)
		(AT (IF (MEMQ (CAR X) '(KST-AT  AT KST-NUM))
			'OK
			(SIGNAL USER 2) NIL))
		(N-KST *A FAIRE*******)
                ((NE-LIST NE-KST) (IF (NULL (CADR X)) 'OK (SIGNAL USER 3) NIL))
		()))
  ))		


;	********** STEPPER     **********         ;

(DE STEPPER ()
   (PRINT '$PC '= $PC)
   (PRINT 'IN-STEP)
   (LET ((-X- (READ))) (IF (NULL -X-) T 
			   (PRINT (EVAL -X-)) (SELF (READ)))))

;	********** THE-MODULES **********         ;

(DEF-MOD CAR
 (RES: ANY
  TYPE: SUBR
  NARGS: 1
  TARGS: (SEQN (VERIFY NE-LIST))
 ))